home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 32 / lab.zip / LABELLE.BAS next >
BASIC Source File  |  1988-07-20  |  11KB  |  281 lines
  1. 'La Belle Lucie by George Leotti, July 1988
  2. DECLARE SUB DisplayCards ()
  3. DECLARE SUB Shuffle ()
  4. DECLARE SUB ClrLine (row%, x%)
  5. DECLARE SUB Convert (r%, s%, r1%, s1%)
  6. DECLARE SUB FindCard (r%, x%, w%, flag%)
  7. DECLARE SUB LabHelp ()
  8. DEFINT A-Z
  9. COMMON SHARED r$, s$, cards, m$
  10. DIM SHARED deck(52), pile(24), colr(3)
  11. colr(0) = 4: colr(1) = 4: r$ = "A23456789TJQK": s$ = "HDCS"
  12. xcolor = SCREEN(1, 1, 1): CALL LabHelp
  13.  
  14. Newgame:
  15. COLOR 15, 2: CLS : cards = 52: deal = 2 'initialize vars for new game
  16. FOR i = 1 TO 52: deck(i) = i: NEXT: FOR i = 1 TO 24: pile(i) = 0: NEXT
  17. LOCATE 2, 7, 0: PRINT "La Belle Lucie": LOCATE 2, 59: PRINT "Deal    Cards"
  18. LOCATE 3, 60: PRINT deal: LOCATE 3, 68: PRINT cards
  19. CALL Shuffle: CALL DisplayCards  'shuffle cards and deal them
  20.  
  21. Mainloop:
  22. COLOR 15, 2: IF cards = 0 THEN GOTO Endhand 'a winner
  23. LOCATE 24, 26: PRINT "(Q)uit (H)elp (S)huffle"; : GOSUB Decide 'get move
  24. CALL Convert(rank, suit, rank1, suit1)
  25. IF rank < 1 OR (LEN(m$) > 3 AND rank1 < 1) THEN x = 1: GOSUB Badmove
  26.  
  27. Movecard:
  28. CALL FindCard(rank, x, w, 0)
  29. IF w = 0 THEN x = 2: GOSUB Badmove 'card not on top of pile
  30.  
  31. Okay:
  32. IF rank1 > 0 THEN
  33.    flag = 1: CALL FindCard(rank1, x1, w1, flag)
  34.    IF flag THEN x = flag: GOSUB Badmove
  35. 'okay to move card within tableau
  36.    pile(w1) = pile(w1) + 1: pile(w) = pile(w) - 1 'adjust piles
  37.    IF x > x1 THEN 'move card down in deck
  38.       FOR i = x TO x1 + 2 STEP -1
  39.          SWAP deck(i - 1), deck(i)
  40.       NEXT
  41.    ELSE 'move card up in deck
  42.       FOR i = x TO x1 - 1
  43.          SWAP deck(i + 1), deck(i)
  44.       NEXT
  45.    END IF
  46. ELSE 'move card from tableau to foundation
  47.    IF rank - suit * 13 > 1 THEN 'move non-aces
  48.       FOR i = 20 TO 23
  49.          IF rank - pile(i) = 1 AND suit = pile(i) \ 13 THEN pile(i) = rank: EXIT FOR
  50.       NEXT
  51.       IF rank <> pile(i) THEN x = 6: GOSUB Badmove 'card can't go on foundation.
  52.    ELSE 'move aces
  53.       FOR i = 20 TO 23
  54.          IF pile(i) = 0 THEN pile(i) = rank: EXIT FOR
  55.       NEXT
  56.    END IF
  57.    pile(w) = pile(w) - 1: cards = cards - 1: deck(x) = 0
  58.    FOR j = x TO cards 'fix hole in deck
  59.       SWAP deck(j), deck(j + 1)
  60.    NEXT
  61. 'display foundation pile i
  62.    col = 28 + 6 * (i - 20): r = rank - suit * 13: COLOR colr(suit), 7
  63.    LOCATE 1, col: PRINT MID$(r$, r, 1); "    "
  64.    LOCATE 2, col: PRINT CHR$(3 + suit); "    "
  65.    LOCATE 3, col: PRINT "    "; CHR$(3 + suit)
  66.    LOCATE 4, col: PRINT "    "; MID$(r$, r, 1)
  67.    IF r = 13 THEN COLOR , 2: LOCATE 3, 9 + 2 * (i - 20): PRINT CHR$(3 + suit)
  68. END IF
  69. IF pile(w) = 0 THEN 'fix hole in tableau
  70.    FOR i = w TO 18
  71.       SWAP pile(i), pile(i + 1)
  72.    NEXT
  73. END IF
  74. COLOR 15, 2: LOCATE 3, 68: PRINT cards
  75. IF MID$(m$, 3, 1) = "-" AND rank - suit * 13 < 13 THEN 'do range if not king
  76.    rank = rank + 1: GOTO Movecard 'do next card in range.
  77. END IF
  78. Entry: CALL DisplayCards: GOTO Mainloop
  79.  
  80. Reshuffle:  'check for reshuffle & legal draw on last reshuffle
  81. IF deal = 0 THEN x = 7: GOSUB Badmove
  82. CALL Shuffle: deal = deal - 1: LOCATE 3, 60: PRINT deal
  83. CALL DisplayCards: IF deal THEN GOTO Mainloop 'not last shuffle
  84.  
  85. Reloop:     'get move on last shuffle
  86. COLOR 15, 2: LOCATE 24, 26: PRINT "(Q)uit (H)elp (N)one   ";
  87. GOSUB Decide 'get move
  88. IF LEN(m$) = 3 THEN m$ = LEFT$(m$, 2)
  89. CALL Convert(rank, suit, rank1, suit1)
  90. x = 0: IF rank < 1 OR (LEN(m$) > 3 AND rank1 < 1) THEN x = 1: GOSUB Badmove
  91. FOR i = 1 TO cards 'get postion of card rank in tableau/pile
  92.    IF deck(i) = rank THEN x = i: w = x \ 3 + 1 + (x / 3 = x \ 3): EXIT FOR
  93. NEXT: IF x = 0 THEN x = 2: GOSUB Badmove
  94. GOTO Okay 'ok to move card
  95.  
  96. Endhand:
  97. CALL ClrLine(6, 19) 'clear lower screen
  98. IF cards = 0 THEN 'game won, flash suit symbols.
  99.    won = won + 1: LOCATE 3, 9
  100.    FOR i = 20 TO 23
  101.         T = pile(i) \ 13 - 1: COLOR 16 + colr(T), 2: PRINT CHR$(3 + T); " ";
  102.    NEXT: COLOR 15
  103. ELSE
  104.    lost = lost + 1
  105. END IF
  106. LOCATE 7, 26: PRINT "You've won"; won; "game"; STRING$(ABS(won > 1 OR won = 0), 115);
  107. PRINT " and lost"; lost; "game"; STRING$(ABS(lost > 1 OR lost = 0), 115); "."
  108. LOCATE 9, 30: PRINT "Do you wish to play another?"
  109. DO: m$ = UCASE$(INKEY$): LOOP WHILE INSTR(" YN", m$) < 2
  110. IF m$ = "Y" THEN GOTO Newgame
  111.  
  112. Endgame:
  113. COLOR xcolor MOD 16, xcolor \ 16: CLS : LOCATE , , 1: END
  114.  
  115. Decide:  'get moves and other input
  116. CALL ClrLine(22, 1)
  117. IF SCREEN(24, 41) = 78 THEN
  118.    COLOR 0, 2: PRINT "Enter a card to draw or move";
  119. ELSE
  120.    PRINT "What is your move";
  121. END IF
  122. INPUT m$: m$ = UCASE$(m$): CALL ClrLine(22, 1): COLOR 15, 2
  123. SELECT CASE m$
  124.    CASE "Q"
  125.       PRINT "Quit (G)ame or (H)and or (O)ops?"
  126.       DO: m$ = UCASE$(INKEY$): LOOP WHILE INSTR(" GHO", m$) < 2
  127.       IF m$ = "G" THEN RETURN Endgame
  128.       IF m$ = "H" THEN RETURN Endhand
  129.       GOTO Decide
  130.    CASE "N"
  131.       RETURN Mainloop
  132.    CASE "H"
  133.       SCREEN , , , 1: DO: LOOP WHILE INKEY$ = "": SCREEN , , , 0
  134.       COLOR 15, 2: GOTO Decide
  135.    CASE "S"
  136.       IF SCREEN(24, 41) = 78 THEN GOTO Decide
  137.       RETURN Reshuffle
  138.    CASE ELSE
  139.       IF LEN(m$) < 2 THEN x = 1: GOSUB Badmove
  140.       RETURN
  141. END SELECT
  142.  
  143. Badmove: 'display errors
  144. SELECT CASE x
  145.    CASE 1
  146.       e$ = "I don't understand your input.": rank = 0: rank1 = 0
  147.    CASE 2
  148.       e$ = MID$(r$, rank - suit * 13, 1) + CHR$(3 + suit) + " Is not available!"
  149.    CASE 3
  150.       e$ = "Kings can't be moved within the tableau!"
  151.    CASE 4
  152.       e$ = "Move any available ace to fondation."
  153.    CASE 5
  154.       e$ = MID$(r$, rank - suit * 13, 1) + CHR$(3 + suit) + " can NOT be moved to " + MID$(r$, rank1 - suit1 * 13, 1) + CHR$(3 + suit1) + "!"
  155.    CASE 6
  156.       e$ = MID$(r$, rank - suit * 13, 1) + CHR$(3 + suit) + " can not be moved to fondation!"
  157.    CASE 7
  158.       e$ = "No shuffles left!"
  159. END SELECT
  160. IF MID$(m$, 3, 1) = "-" AND SCREEN(24, 41) <> 78 THEN 'skip razz if end of range
  161.    x = INSTR(r$, LEFT$(m$, 1))
  162.    IF x - ABS(x > 13) * 13 <> rank - suit * 13 AND LEN(m$) = 3 THEN RETURN Entry
  163. END IF
  164. CALL ClrLine(22, 1): PRINT e$: SOUND 47, 5: 'print error then razz'em &
  165. ti! = TIMER + 2: DO WHILE TIMER < ti!: LOOP 'wait around 2 seconds
  166. IF SCREEN(24, 41) = 78 THEN RETURN Reloop
  167. RETURN Mainloop
  168.  
  169. SUB ClrLine (row, x) 'erase x lines starting at row
  170. LOCATE row, 1 'this sub saves around 5000 bytes over VIEW PRINT x to y: CLS!!
  171. DO
  172.    PRINT STRING$(80, 32); : x = x - 1
  173. LOOP WHILE x
  174. LOCATE row, 7
  175. END SUB
  176.  
  177. SUB Convert (r, s, r1, s1)
  178. 'convert move notation m$ to deck notation DECK(1-52), r is from r1 is to
  179. r = INSTR(r$, LEFT$(m$, 1)): IF r = 0 THEN EXIT SUB 'get rank of from card
  180. s = INSTR(s$, MID$(m$, 2, 1)) - 1 'get suit of from card
  181. IF LEN(m$) > 3 THEN 'get rank & suit of to card
  182.    r1 = INSTR(r$, MID$(m$, 3, 1)): IF r1 = 0 THEN EXIT SUB
  183.    s1 = INSTR(s$, MID$(m$, 4, 1)) - 1
  184. ELSE 'no to card.
  185.    s1 = 0: r1 = 0
  186. END IF
  187. r = s * 13 + r: r1 = s1 * 13 + r1 'value of card, 1-52
  188. END SUB
  189.  
  190. SUB DisplayCards 'display tableau
  191. CALL ClrLine(6, 14): i = 1: x = pile(1): c = 1: row = 6: col = 10
  192. DO WHILE x
  193.    FOR j = 0 TO x - 1: d = deck(c + j) 'get card number
  194.       suit = d \ 13 + (d \ 13 = d / 13) 'cange it to suit
  195.       m$ = MID$(r$, d - suit * 13, 1)   '& rank
  196.       COLOR colr(suit), 7
  197.       LOCATE row, col + j: PRINT m$ 'display suit/rank (upper left corner)
  198.       LOCATE row + 1, col + j: PRINT CHR$(3 + suit) 'of each card in pile
  199.    NEXT: x$ = STRING$(3 + x, 32)
  200.    LOCATE row, col + j: PRINT "    " 'display rest of pile.
  201.    LOCATE row + 1, col + j: PRINT "    "
  202.    LOCATE row + 2, col: PRINT x$; CHR$(3 + suit)
  203.    LOCATE row + 3, col: PRINT x$; m$
  204.    i = i + 1: col = col + 5 + x: c = c + j: x = pile(i)
  205.    IF col + x + 4 > 75 THEN col = 10: row = row + 5
  206. LOOP
  207. END SUB
  208.  
  209. SUB FindCard (r, x, w, flag)
  210. SHARED rank, suit, rank1, suit1
  211. x = 0: w = 0
  212. FOR i = 1 TO 18 'check top card for a match with r (rank or rank1)
  213.    x = x + pile(i)
  214.    IF deck(x) = r THEN w = i: EXIT FOR
  215. NEXT
  216. IF flag = 0 THEN EXIT SUB 'exits when r=rank
  217. IF w = 0 THEN rank = rank1: suit = suit1: flag = 2: EXIT SUB
  218. IF rank - suit * 13 = 13 THEN flag = 3: EXIT SUB
  219. IF rank - suit * 13 = 1 THEN flag = 4: EXIT SUB
  220. IF rank1 - rank <> 1 THEN flag = 5: EXIT SUB
  221. flag = 0
  222. END SUB
  223.  
  224. SUB LabHelp
  225. 'put help screen on SCREEN 1
  226. WIDTH 80, 25: SCREEN 0, , 1, 0: COLOR 15, 1: CLS
  227. PRINT "    The object of La Belle Lucie is to move all cards from the tableau to the"
  228. PRINT "foundation in ascending order, Ace through King according to suit."
  229. PRINT : PRINT "    Initially 18 piles are dealt to the tableau. 17 piles of three cards each,"
  230. PRINT "and 1 pile with 1 card. Cards my be moved within the tableau in descending"
  231. PRINT "order, according to suit. You may move only the TOP (right-most) card in any"
  232. PRINT "pile to the foundation, or to another top card in the tableau. Kings can only"
  233. PRINT "be moved to their respective foundation piles."
  234. PRINT : PRINT "    Moves are entered as simple abbreviations of the card to be moved. For"
  235. PRINT "example: '7S8S' means move 7 of Spade to 8 of Spade. 'AC' means move Ace of Club";
  236. PRINT "to a foundation pile. If you have a run of cards, say 2 through 6 of Hearts that";
  237. PRINT "can be moved to a foundation pile, you may enter it as '2H-'."
  238. PRINT
  239. PRINT "    You are allowed two reshuffles after the first deal. On your final shuffle"
  240. PRINT "you may move any one card from anywhere in a tableau pile to the foundation, or"
  241. PRINT "to a top card in the tableau according to the above rules. Enter an 'S' alone"
  242. PRINT "at the prompt to shuffle the cards."
  243. PRINT
  244. PRINT "    You may quit a game, or hand, by typing 'Q' at the 'What's your next move'"
  245. PRINT "prompt. Enter 10's as 'T'. Any letters entered may be in UPPER, or lower, case."
  246. PRINT : PRINT , , "<Press any key to resume game>": SCREEN , , 0, 0
  247. 'opening screen...
  248. COLOR 15, 2: CLS : LOCATE 19, 29, 0: c = 2
  249. PRINT "Press any key to begin."
  250. COLOR 0: LOCATE 21, 65
  251. PRINT "Programmed by": LOCATE , 65: PRINT "George Leotti"
  252. LOCATE , 65: PRINT "with Microsoft": LOCATE , 65: PRINT "QuickBASIC 4.0";
  253. FOR i = 3 TO 6
  254.    LOCATE 11, 30 + i + (i - 3): COLOR 16 + colr(i - 3): PRINT CHR$(i)
  255.    LOCATE 13, 37 + i + (i - 3): COLOR 16 + colr((9 - i) - 3): PRINT CHR$(9 - i)
  256. NEXT
  257. DO
  258.    LOCATE 12, 33
  259.    FOR i = 1 TO 15
  260.       COLOR colr(ABS(c \ 2 = c / 2) + 1): IF c = 2 THEN c = 3 ELSE c = 2
  261.       PRINT MID$("La Belle Lucie ", i, 1);
  262.    NEXT
  263.    ti! = TIMER + .2: DO WHILE TIMER < ti!: LOOP
  264. LOOP WHILE INKEY$ = ""
  265. END SUB
  266.  
  267. SUB Shuffle
  268. CALL ClrLine(22, 1): PRINT "Shuffling cards...": RANDOMIZE TIMER
  269. FOR j = 1 TO 2 + INT(RND * 3 + 1) 'number of times to mix
  270.    FOR i = 1 TO cards     'mix'em
  271.       SWAP deck(INT(RND * cards + 1)), deck(INT(RND * cards + 1))
  272.    NEXT
  273. NEXT
  274. FOR i = 1 TO cards \ 3
  275.    pile(i) = 3  '3 cards in each pile
  276. NEXT
  277. pile(i) = cards MOD 3 'last pile gets remainder
  278. pile(i + 1) = 0 'end of piles
  279. END SUB
  280.  
  281.